home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 3: Developer Tools / Linux Cubed Series 3 - Developer Tools.iso / devel / lang / lisp / stk-3.003 / stk-3 / stk / 3.1 / STk / Text.stklos < prev    next >
Encoding:
Text File  |  1996-07-29  |  16.0 KB  |  524 lines
  1. ;;;;
  2. ;;;; T e x t . s t k      --  Text class definition
  3. ;;;;
  4. ;;;; Copyright ⌐ 1993-1996 Erick Gallesio - I3S-CNRS/ESSI <eg@unice.fr>
  5. ;;;; 
  6. ;;;; Permission to use, copy, and/or distribute this software and its
  7. ;;;; documentation for any purpose and without fee is hereby granted, provided
  8. ;;;; that both the above copyright notice and this permission notice appear in
  9. ;;;; all copies and derived works.  Fees for distribution or use of this
  10. ;;;; software or derived works may only be charged with express written
  11. ;;;; permission of the copyright holder.  
  12. ;;;; This software is provided ``as is'' without express or implied warranty.
  13. ;;;;
  14. ;;;;           Author: Erick Gallesio [eg@kaolin.unice.fr]
  15. ;;;;    Creation date: 22-Aug-1993 10:55
  16. ;;;; Last file update: 16-Jan-1996 15:21
  17.  
  18. (require "Basics")
  19.  
  20. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  21. ;;;;
  22. ;;;; <Text> class definition
  23. ;;;;
  24. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  25. (define-class <Text> (<Tk-simple-widget> <Tk-sizeable> <Tk-editable> 
  26.               <Tk-selectable> <Tk-text-selectable>)
  27.   ((spacing1         :init-keyword :spacing1
  28.              :accessor     spacing1
  29.              :allocation   :tk-virtual)
  30.    (spacing2         :init-keyword :spacing2
  31.              :accessor     spacing2
  32.              :allocation   :tk-virtual)
  33.    (spacing3         :init-keyword :spacing3
  34.              :accessor     spacing3
  35.              :allocation   :tk-virtual)
  36.    (state            :init-keyword :state
  37.              :accessor     state
  38.              :allocation   :tk-virtual)
  39.    (tabs         :init-keyword :tabs
  40.              :accessor     tabs
  41.              :allocation   :tk-virtual)
  42.    (x-scroll-command :init-keyword :x-scroll-command
  43.              :accessor     x-scroll-command
  44.              :tk-name      xscrollcommand
  45.              :allocation   :tk-virtual)
  46.    (y-scroll-command :init-keyword :y-scroll-command
  47.              :accessor     y-scroll-command
  48.              :tk-name      yscrollcommand
  49.              :allocation   :tk-virtual)
  50.    (wrap             :init-keyword :wrap
  51.              :accessor     wrap
  52.              :allocation   :tk-virtual)
  53.    (set-grid         :accessor     set-grid
  54.              :init-keyword :set-grid
  55.              :allocation   :tk-virtual
  56.              :tk-name      setgrid)
  57.    (pad-x            :accessor     pad-x
  58.              :init-keyword :pad-x
  59.              :allocation   :tk-virtual
  60.              :tk-name      padx)
  61.    (pad-y            :accessor     pad-y
  62.              :init-keyword :pad-y
  63.              :allocation   :tk-virtual
  64.              :tk-name      pady)
  65.    (value            :accessor     value
  66.              :init-keyword :value
  67.              :allocation   :virtual
  68.              :slot-ref     (lambda (o)
  69.                      ((slot-ref o 'Id) 'get "1.0" "end"))
  70.              :slot-set!    (lambda (o v)
  71.                      ((slot-ref o 'Id) 'delete "1.0" "end")
  72.                      ((slot-ref o 'Id) 'insert "1.0" v)))
  73.    ;; The hash-table of associated tags
  74.    (tags         :initform       (make-hash-table))))
  75.  
  76. (define-method tk-constructor ((self <Text>))
  77.   Tk:text)
  78.  
  79.  
  80. (define-method initialize ((self <Text>) initargs)
  81.   (next-method)
  82.   ;; Create a tag text selection (because Tk handle the tag "sel" specifically
  83.   (make <Text-tag> :parent self :Tid "sel")
  84.   ;; Create "insert" and "current" mark
  85.   (make <Text-mark> :parent self :Mid "insert"  :index "1.0")
  86.   (make <Text-mark> :parent self :Mid "current" :index "1.0"))  
  87.  
  88.  
  89. (define-method destroy ((self <Text>))
  90.   ;; Destroy all the embedded tags 
  91.   (hash-table-for-each (slot-ref self 'tags) 
  92.                (lambda (k v) (catch (destroy v))))
  93.   (next-method))
  94.  
  95. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  96. ;;;;
  97. ;;;; <Text> methods
  98. ;;;;
  99. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  100.  
  101. ;;;
  102. ;;; Bounding-box
  103. ;;;
  104. (define-method bounding-box ((self <Text>) index)
  105.   ((slot-ref self 'Id) 'bbox index))
  106.  
  107. ;;;
  108. ;;; Compare-index
  109. ;;;
  110. (define-method compare-index ((self <Text>) index1 op index2)
  111.   ((slot-ref self 'Id) 'compare index1 op index2))
  112.  
  113. ;;;
  114. ;;; Text-delete
  115. ;;;
  116. (define-method text-delete ((self <Text>) index1)
  117.   ((slot-ref self 'Id) 'delete index1))  
  118.  
  119. (define-method text-delete ((self <Text>) index1 index2)
  120.   ((slot-ref self 'Id) 'delete index1 index2))
  121.  
  122.  
  123. ;;;
  124. ;;; Text-line-info
  125. ;;; 
  126. (define-method text-line-info ((self <Text>) index)
  127.   ((slot-ref self 'Id) 'dlineinfo index))
  128.  
  129. ;;;
  130. ;;; Text-get
  131. ;;;
  132. (define-method text-get ((self <Text>) index1)
  133.   ((slot-ref self 'Id) 'get index1)) 
  134.  
  135. (define-method text-get ((self <Text>) index1 index2)
  136.   ((slot-ref self 'Id) 'get index1 index2))
  137.  
  138. ;;;
  139. ;;; Text-index
  140. ;;;
  141. (define-method text-index ((self <Text>) index)
  142.   ((slot-ref self 'Id) 'index index))
  143.  
  144. ;;;
  145. ;;; Text-insert
  146. ;;;
  147. (define-method text-insert ((self <Text>) . l)
  148.   (apply (slot-ref self 'Id) 'insert l))
  149.  
  150. ;;;
  151. ;;; Text-search
  152. ;;;
  153. (define-method text-search ((self <Text>) . l)
  154.   (apply (slot-ref self 'Id) 'search l))
  155.  
  156. ;;;
  157. ;;; Text-see
  158. ;;;
  159. (define-method text-see ((self <Text>) index)
  160.   (apply (slot-ref self 'Id) 'see index))
  161.  
  162. ;;;
  163. ;;; Text-tags
  164. ;;; 
  165. (define-method text-tags ((self <Text>) . args)
  166.   (map (lambda (x) (Tid->instance self x))
  167.        (apply (slot-ref self 'Id) 'tag 'names args)))
  168.  
  169. ;;;
  170. ;;; Text-marks
  171. ;;;
  172. (define-method text-marks ((self <Text>))
  173.   (map (lambda (x) (Tid->instance self x))
  174.        ((slot-ref self 'Id) 'mark 'names)))
  175.  
  176. ;;;
  177. ;;; Text-x-view
  178. ;;;
  179. (define-method text-x-view ((self <Text>) . l)
  180.   (apply (slot-ref self 'Id) 'xview l))
  181.  
  182. ;;;
  183. ;;; Text-x-view
  184. ;;;
  185. (define-method text-y-view ((self <Text>) . l)
  186.   (apply (slot-ref self 'Id) 'yview l))
  187.  
  188.  
  189. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  190. ;;;;
  191. ;;;; Other <Text> methods
  192. ;;;;
  193. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  194.  
  195. (define-method get-line ((self <Text>) line)
  196.   (let ((l (format #f "~A.0" line)))
  197.     (if (compare-index self l ">" "end") 
  198.     #f
  199.     ((slot-ref self 'Id) 'get (& line ".0" ) (& line ".0 lineend")))))
  200.  
  201. (define-method text-save ((self <Text>) filename)
  202.   (with-output-to-file filename (lambda() (display (slot-ref self 'value)))))
  203.  
  204. (define-method text-read ((self <Text>) filename)
  205.   (slot-set! self 'value (with-input-from-file filename 
  206.                (lambda() 
  207.                  (let ((res ""))
  208.                    (do ((l (read-line) (read-line)))
  209.                    ((eof-object? l) (string-append res "\n"))
  210.                  (set! res (if (string=? res "")
  211.                            l
  212.                            (string-append res "\n" l)))))))))
  213.  
  214. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  215. ;;;;
  216. ;;;; <Text-tag> class definition
  217. ;;;;
  218. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  219.  
  220. (define-class <Text-tag> (<Tk-object>)
  221.   ((Tid            :getter       Tid)
  222.    (background     :accessor      background    
  223.            :init-keyword :background   
  224.            :allocation   :tk-virtual)
  225.    (bg-stipple     :accessor     bg-stipple    
  226.            :init-keyword :bg-stipple   
  227.            :tk-name      bgstipple 
  228.            :allocation   :tk-virtual)
  229.    (border-width   :accessor     border-width  
  230.            :init-keyword :border-width 
  231.            :tk-name      borderwidth 
  232.            :allocation   :tk-virtual)
  233.    (fg-stipple     :accessor     fg-stipple    
  234.            :init-keyword :fg-stipple   
  235.            :tk-name      fgstipple 
  236.            :allocation   :tk-virtual)
  237.    (font           :accessor     font          
  238.            :init-keyword :font   
  239.            :allocation   :tk-virtual)
  240.    (foreground     :accessor     foreground    
  241.            :init-keyword :foreground   
  242.            :allocation   :tk-virtual)
  243.    (justify       :accessor     justify
  244.            :init-keyword :justify
  245.            :allocation   :tk-virtual)
  246.    (lmargin1       :accessor     lmargin1
  247.            :init-keyword :lmargin1
  248.            :allocation   :tk-virtual)
  249.    (lmargin2       :accessor     lmargin2
  250.            :init-keyword :lmargin2
  251.            :allocation   :tk-virtual)
  252.    (offset       :accessor     offset
  253.            :init-keyword :offset
  254.            :allocation   :tk-virtual)
  255.    (overstrike       :accessor     overstrike
  256.            :init-keyword :overstrike
  257.            :allocation   :tk-virtual)
  258.    (relief         :accessor     relief        
  259.            :init-keyword :relief   
  260.            :allocation   :tk-virtual)
  261.    (rmargin       :accessor     rmargin
  262.            :init-keyword :rmargin
  263.            :allocation   :tk-virtual)
  264.    (spacing1       :accessor     spacing1
  265.            :init-keyword :spacing1
  266.            :allocation   :tk-virtual)
  267.    (spacing2       :accessor     spacing2
  268.            :init-keyword :spacing2
  269.            :allocation   :tk-virtual)
  270.    (spacing3       :accessor     spacing3
  271.            :init-keyword :spacing3
  272.            :allocation   :tk-virtual)
  273.    (tabs       :accessor     tabs
  274.            :init-keyword :tabs
  275.            :allocation   :tk-virtual)
  276.    (underline      :accessor     underline
  277.            :init-keyword :underline
  278.            :allocation   :tk-virtual)
  279.    (wrap       :accessor     wrap
  280.            :init-keyword :wrap
  281.            :allocation   :tk-virtual))
  282.   :metaclass <Tk-tag-metaclass>)
  283.  
  284. (define-method initialize ((self <Text-tag>) initargs)
  285.   (let ((parent (get-keyword :parent initargs #f)))
  286.     ;; Verify that parent exists and that it is a <Text>
  287.     (unless  parent
  288.        (error "**** You must specify the text which contain this tag"))
  289.     (unless (is-a? parent <Text>)
  290.        (error "**** Specified text ~A is not valid" parent))
  291.  
  292.     (let ((parent-Id (slot-ref parent 'Id))
  293.       (Tid          (get-keyword :Tid initargs (gensym "tag_"))))
  294.       (slot-set! self 'Id     parent-Id)
  295.       (slot-set! self 'Eid    parent-Id)
  296.       (slot-set! self 'parent parent)
  297.       (slot-set! self 'Tid    Tid)
  298.  
  299.       ;; Create the tag (configuring it suffice to create it)
  300.       (apply (slot-ref parent 'Id) 'tag 'configure Tid 
  301.                         (get-keyword :tk-options initargs '()))
  302.  
  303.       ;; Add this tag to the hash-table
  304.       (hash-table-put! (slot-ref parent 'tags) Tid self)
  305.       (next-method))))
  306.  
  307.  
  308. ;;; Tk-write-object is called when a STklos object is passed to a Tk-command.
  309. ;;; By default, we do the same job as write; but if an object is a <Tk-widget>
  310. ;;; we will pass it its Eid. This method does this job.
  311. (define-method Tk-write-object((self <Text-tag>) port)
  312.   (write (slot-ref self 'Tid) port))
  313.  
  314. ;;;
  315. ;;; Utility: Tid->instance
  316. ;;;
  317. (define (Tid->instance text id)
  318.   (hash-table-get (slot-ref text 'tags) id id))
  319.  
  320. ;;;
  321. ;;; Tag-add
  322. ;;;
  323. (define-method tag-add ((self <Text-tag>) index1)
  324.   ((slot-ref self 'Id) 'tag 'add (slot-ref self 'Tid) index1))
  325.  
  326. (define-method tag-add ((self <Text-tag>) index1 index2)
  327.   ((slot-ref self 'Id) 'tag 'add (slot-ref self 'Tid) index1 index2))
  328.  
  329. ;;;
  330. ;;; Bind
  331. ;;;
  332. (define-method bind ((self <Text-tag>) . args)
  333.   (apply (slot-ref self 'Id) 'tag 'bind (slot-ref self 'Tid) args))
  334.  
  335. ;;;
  336. ;;; Destroy (for tags)
  337. ;;;
  338. (define-method destroy ((self <Text-tag>))
  339.   (let ((parent (slot-ref self 'parent))
  340.     (Tid    (slot-ref self 'Tid)))
  341.     ;; Destroy the tag from the Text
  342.     ((slot-ref self 'Id) 'tag 'delete Tid)
  343.     ;; Delete it from the hash table
  344.     (hash-table-remove! (slot-ref parent 'tags) Tid)
  345.     ;; Change its class to <Destroyed-object>
  346.     (change-class self <Destroyed-object>)))
  347.  
  348. ;;;
  349. ;;; Tag-lower
  350. ;;;
  351. (define-method tag-lower ((self <Text-tag>))
  352.   ((slot-ref self 'Id) 'tag 'lower (slot-ref self 'Tid)))
  353.  
  354. (define-method tag-lower ((self <Text-tag>) below-this)
  355.   ((slot-ref self 'Id) 'tag 'lower (slot-ref self 'Tid) below-this))
  356.  
  357. ;;;
  358. ;;; Tag Raise
  359. ;;;
  360. (define-method tag-raise ((self <Text-tag>))
  361.   ((slot-ref self 'Id) 'tag 'raise (slot-ref self 'Tid)))
  362.  
  363. (define-method tag-raise ((self <Text-tag>) below-this)
  364.   ((slot-ref self 'Id) 'tag 'raise (slot-ref self 'Tid) below-this))
  365.  
  366. ;;;
  367. ;;; Tag-next-range
  368. ;;;
  369. (define-method tag-next-range ((self <Text-tag>) index1)
  370.   ((slot-ref self 'Id) 'tag 'nextrange (slot-ref self 'Tid) index1))
  371.  
  372. (define-method tag-next-range ((self <Text-tag>) index1 index2)
  373.   ((slot-ref self 'Id) 'tag 'nextrange (slot-ref self 'Id) index1 index2))
  374.  
  375.   
  376. ;;;
  377. ;;; Tag-ranges
  378. ;;;
  379. (define-method tag-ranges ((self <Text-tag>))
  380.   ((slot-ref self 'Id) 'tag 'ranges (slot-ref self 'Tid)))
  381.  
  382. ;;;
  383. ;;; Tag Remove
  384. ;;;
  385. (define-method tag-remove ((self <Text-tag>) index1)
  386.   ((slot-ref self 'Id) 'tag 'remove (slot-ref self 'Tid) index1)) 
  387.  
  388. (define-method tag-remove ((self <Text-tag>) index1 index2)
  389.   ((slot-ref self 'Id) 'tag 'remove (slot-ref self 'Tid) index1 index2))
  390.  
  391.  
  392. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  393. ;;;;
  394. ;;;; <Text-mark> class definition
  395. ;;;;
  396. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  397.  
  398. (define-class <Text-mark> (<Tk-object>)
  399.   ((Mid     :getter  Mid)
  400.    (gravity :accessor       gravity
  401.         :init-keyword :gravity
  402.         :allocation   :virtual
  403.         :slot-ref      (lambda (o)   
  404.                 ((slot-ref o 'Id) 'mark 'gravity (slot-ref o 'Mid)))
  405.         :slot-set!      (lambda (o v)
  406.                 ((slot-ref o 'Id) 'mark 'gravity (slot-ref o 'Mid) v))))
  407.    :metaclass <Tk-metaclass>)
  408.  
  409. (define-method Tk-write-object ((self <Text-mark>) port)
  410.   (write (slot-ref self 'Mid) port))
  411.  
  412. (define-method initialize ((self <Text-mark>) initargs)
  413.   (let ((parent (get-keyword :parent initargs #f))
  414.     (index  (get-keyword :index  initargs #f)))
  415.     
  416.     ;; Verify that parent exists and that it is a <Text>
  417.     (unless  parent
  418.        (error "**** You must specify the text which contain this mark"))
  419.     (unless (is-a? parent <Text>)
  420.        (error "**** Specified text ~A is not valid" parent))
  421.     (unless index
  422.        (error "**** You must supply an index for the mark"))
  423.  
  424.     (let ((parent-Id (slot-ref parent 'Id))
  425.       (Mid          (get-keyword :Mid initargs (gensym "mark_"))))
  426.       (slot-set! self 'Id     parent-Id)
  427.       (slot-set! self 'Eid    parent-Id)
  428.       (slot-set! self 'parent parent)
  429.       (slot-set! self 'Mid    Mid)
  430.  
  431.       ;; Add this mark to the hash-table
  432.       (hash-table-put! (slot-ref parent 'tags) Mid self)
  433.      
  434.       ;; Create the mark 
  435.       (parent-Id 'mark 'set Mid index)))
  436.   (next-method))
  437.  
  438. (define-method mark-set ((self <Text-mark>) where)
  439.   ((slot-ref self 'Id) 'mark 'set (slot-ref self 'Mid) where))
  440.  
  441. (define-method mark-unset ((self <Text-mark>))
  442.   ((slot-ref self 'Id) 'mark 'unset (slot-ref self 'Mid)))
  443.  
  444.  
  445. ;;;
  446. ;;; Destroy (for marks)
  447. ;;;
  448. (define-method destroy ((self <Text-mark>))
  449.   (let ((parent (slot-ref self 'parent))
  450.     (Mid    (slot-ref self 'Mid)))
  451.     ;; Destroy the tag from the Text
  452.     ((slot-ref self 'Id) 'tag 'delete Mid)
  453.     ;; Delete it from the hash table
  454.     (hash-table-remove! (slot-ref parent 'tags) Mid)
  455.     ;; Change its class to <Destroyed-object>
  456.     (change-class self <Destroyed-object>)))
  457.  
  458. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  459. ;;;;
  460. ;;;; <Text-window> class definition
  461. ;;;;
  462. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  463.  
  464. (define-class <Text-window> (<Tk-object>)
  465.   ((index    :accessor    index)
  466.     (align    :init-keyword     :align
  467.         :accessor         align
  468.         :allocation       :tk-virtual)
  469.    (create    :init-keyword    :create
  470.         :accessor    create
  471.         :allocation    :tk-virtual)
  472.    (pad-x    :init-keyword    :pad-x
  473.         :accessor    pad-x
  474.         :tk-name    padx
  475.         :allocation    :tk-virtual)
  476.    (pad-y    :init-keyword    :pad-y
  477.         :accessor    pad-y
  478.         :tk-name    pady
  479.         :allocation    :tk-virtual)
  480.    (stretch    :init-keyword    :stretch
  481.         :accessor    stretch
  482.         :allocation    :tk-virtual)
  483.    (window    :init-keyword    :window
  484.         :accessor    window
  485.         :allocation    :tk-virtual))
  486.    :metaclass <Tk-text-window-metaclass>)
  487.  
  488. (define-method initialize ((self <Text-window>) initargs)
  489.   (let ((parent (get-keyword :parent initargs #f))
  490.     (window (get-keyword :window (get-keyword :tk-options initargs '()) #f))
  491.     (index  (get-keyword :index  initargs #f)))
  492.  
  493.     ;; Verify that parent exists and that it is a <Text>
  494.     (unless  (or parent window)
  495.        (error "**** You must specify the text which contain this window"))
  496.     (if window
  497.     (unless (is-a? (slot-ref window 'parent) <Text>)
  498.        (error "**** Parent of widget '~S' is not a text" window))
  499.     (unless (is-a? parent <Text>)
  500.        (error "**** Specified text ~A is not valid" parent)))
  501.     (unless index
  502.        (error "**** No index specified for this window"))
  503.  
  504.     (let* ((parent    (if window (slot-ref window 'parent) parent))
  505.        (parent-Id (slot-ref parent 'Id)))
  506.       (slot-set! self 'Id     parent-Id)
  507.       (slot-set! self 'Eid    parent-Id)
  508.       (slot-set! self 'parent parent)
  509.       (slot-set! self 'index  index)
  510.  
  511.       ;; Create the tag (configuring it suffice to create it)
  512.       (apply parent-Id 'window 'create index 
  513.                    (get-keyword :tk-options initargs '()))
  514.  
  515.       ;; Add the window to the hash-table
  516.       (hash-table-put! (slot-ref parent 'tags) (gensym) self)
  517.       (next-method))))
  518.  
  519. (define-method embedded-text-windows ((self <Text>))
  520.   ((slot-ref self 'Id) 'window 'names))
  521.  
  522. (require "STF")
  523. (provide "Text")
  524.